Shareware Grab Bag/Shareware Grab Bag.iso/090/byt86jun.arc/INDEXBPP.LST

File List | 1986-02-07 | 10.3 KB | 404 lines

const
  IndexMax          = 1000;
  RecCountErr       =   -2;
  NewFileCreated    =   -1;
  NoError           =    0;
  RecordNotFound    =    1;
  NoMoreRoom        =    2;
  AlreadyExists     =    3;
  OutOfRange        =    4;

type

  Keytype      = string[40];
  FileStr      = string[80];

  DataRec = record
    case Boolean of
      True     : (NumRecs     : Integer);
      False    : (Key         : Keytype;
                  theRest     : Whatever;
      { this represents the rest of your data fields } );
  end;

  IndexRec = record
    Key        : Keytype;
    Num        : Integer
  end;

  IndexList    = array[1..IndexMax] of IndexRec;

var
  KList        : IndexList;
  DFile        : file of DataRec;
  MaxRec       : Integer;

LISTING 1.  Global definitions and declarations.


{            compiler-specific file I/O routines                  }
{      these procedures are specific to TURBO Pascal.  If you
       are using another Pascal compiler, you will need to
       modify them appropriately.  Note that TURBO Pascal does
       not support the standard routines GET and PUT, but instead
       uses READ and WRITE.                                       }

{$I-} { turn off I/O error checking }

procedure FRead(RNum : Integer; var Rec : DataRec; var Error : Integer);
{
     reads record #RNum into Rec
}
begin
  if (RNum < 0) or (RNum > MaxRec)
    then Error := OutOfRange
  else begin
    Seek(DFile,RNum);
    Error := IOResult;
    if Error = NoError then begin
      Read(DFile,Rec);
      Error := IOResult
    end;
    if Error > 0
      then Error := 100 + Error
  end
end; { of proc FRead }

procedure FWrite(RNum : Integer; Rec : DataRec; var Error : Integer);
{
     writes record #RNum into Rec
}
begin
  if (RNum < 0) or (RNum > MaxRec)
    then Error := OutOfRange
  else begin
    Seek(DFile,RNum);
    Error := IOResult;
    if Error = NoError then begin
      Write(DFile,Rec);
      Error := IOResult
    end;
    if Error > 0
      then Error := 100 + Error
  end
end; { of proc FRead }

procedure FOpen(FileName : FileStr; var Error : Integer);
{
       tries to open FileName; if it doesn't exist, creates
       it with the appropriate header record
}
const
  TurboNoFile  =  1; { "no file" error code for TURBO Pascal }
var
  IOCode       : Integer;
  TRec         : DataRec;
begin
  Assign(DFile,FileName);
  Reset(DFile);
  IOCode := IOResult;
  if IOCode = TurboNoFile then begin { file doesn't exist }
    FillChar(TRec,SizeOf(TRec),0);
    Rewrite(DFile);
    TRec.NumRecs := 0;
    FWrite(0,TRec,Error);
    Close(DFile);
    Assign(DFile,Filename);
    Reset(DFile);
    IOCode := IOResult;
    if IOCode = NoError
      then Error := NewFileCreated
  end;
  if IOCode <> NoError
    then Error := 100 + IOCode;
end; { of proc FOpen }

procedure FClose(var Error : Integer);
{
       closes file
}
begin
  Close(DFile);
  Error := IOResult;
  if Error > 0
    then Error := Error + 100
end; { of proc FClose }

{$I+} { turn on I/O error checking }

LISTING 2a.  File I/O routines specific to TURBO Pascal.
-----------


{            compiler-specific file I/O routines                  }
{      these procedures are specific to UCSD Pascal.  If you
       are using another Pascal compiler, you will need to
       modify them appropriately.                                 }

{$I-} { turn off I/O error checking }

procedure FRead(RNum : Integer; var Rec : DataRec; var Error : Integer);
{
     reads record #RNum into Rec
}
begin
  if (RNum < 0) or (RNum > MaxRec)
    then Error := OutOfRange
  else begin
    Seek(DFile,RNum);
    Error := IOResult;
    if Error = NoError then begin
      Get(DFile);
      Error := IOResult;
      if Error = NoError
        then Rec := DFile^
    end;
    if Error <> NoError
      then Error := 100 + Error
  end
end; { of proc FRead }

procedure FWrite(RNum : Integer; Rec : DataRec; var Error : Integer);
{
     writes record #RNum into Rec
}
begin
  if (RNum < 0) or (RNum > MaxRec)
    then Error := OutOfRange
  else begin
    Seek(DFile,RNum);
    Error := IOResult;
    if Error = NoError then begin
      DFile^ := Rec;
      Put(DFile);
      Error := IOResult
    end;
    if Error > 0
      then Error := 100 + Error
  end
end; { of proc FRead }

procedure FOpen(FileName : FileStr; var Error : Integer);
{
       tries to open FileName; if it doesn't exist, creates
       it with the appropriate header record
}
const
  UCSDNoFile   =  1; { "no file" error code for UCSD Pascal }
var
  IOCode       : Integer;
  TRec         : DataRec;
begin
  Reset(DFile,FileName);
  IOCode := IOResult;
  if IOCode = UCSDNoFile then begin { file doesn't exist }
    FillChar(TRec,SizeOf(TRec),Chr(0));
    Rewrite(DFile,FileName);
    TRec.NumRecs := 0;
    FWrite(0,TRec,Error);
    Close(DFile,Lock);
    Reset(DFile,FileName);
    IOCode := IOResult;
    if IOCode = NoError
      then Error := NewFileCreated
  end;
  if IOCode <> NoError
    then Error := 100 + IOCode;
end; { of proc FOpen }

procedure FClose(var Error : Integer);
{
       closes file
}
begin
  Close(DFile,Lock);
  Error := IOResult;
  if Error > 0
    then Error := Error + 100
end; { of proc FClose }

{$I+} { turn on I/O error checking }

LISTING 2b.  File I/O routines specific to UCSD Pascal.
-----------

procedure SortIndexList;
{
     sorts the array KList using a selection sort technique
}
var
  I,J,Min      : Integer;
  Temp         : IndexRec;
begin
  for I := 1 to MaxRec-1 do begin
    Min := I;
    for J := I+1 to MaxRec do
      if KList[J].Key < KList[Min].Key
        then Min := J;
    Temp := KList[I];
    KList[I] := KList[Min];
    KList[Min] := Temp
  end
end; { of proc SortIndexList }

procedure InitStuff(FileName : FileStr; var Error : Integer);
{
     sets everything up for indexing system.  This assumes that
     there are no more than IndexMax (=1000) records, and that the
     records are numbered 1..IndexMax.  Record #0 is the header
     record and is used to store the current number of records
     actively being used in the file
}
var
  Indx,TErr           : Integer;
  TRec                : DataRec;
begin
  Error := NoError;
  FOpen(FileName,Error);
  if Error <= NoError then begin
    MaxRec := 0;
    FRead(0,TRec,TErr);
    Error := TErr;
    MaxRec := TRec.NumRecs;
    for Indx := 1 to MaxRec do begin
      FRead(Indx,TRec,TErr);
      if TErr > 0
        then Error := TErr;
      KList[Indx].Key := TRec.Key;
      KList[Indx].Num := Indx
    end;
    SortIndexList
  end
end; { of proc InitStuff }

procedure CleanUpStuff(var Error : Integer);
{
     this just does an orderly shutdown and should be called
     before you leave your program (or open another data file)
}
var
  TRec                : DataRec;
begin
  TRec.NumRecs := MaxRec; { save out # of records }
  FWrite(0,TRec,Error);
  FClose(Error)
end; { of proc CleanUpStuff }

LISTING 3.  Initialization and cleanup routines.
----------

function FindKey(Key : Keytype) : Integer;
{
     looks for Key in KList; returns location in KList
     if found; otherwise returns - 1
}
var
  L,R,Mid      : Integer;
begin
  L := 1; R := MaxRec;
  repeat
    Mid := (L+R) div 2;
    if Key < KList[Mid].Key
      then R := Mid-1
      else L := Mid+1
  until (Key = KList[Mid].Key) or (L > R);
  if Key = KList[Mid].Key
    then FindKey := Mid
    else FindKey :=  -1
end; { of proc FindKey }

procedure GetRecord(Key : Keytype; var Rec : DataRec;
                    var Error : Integer);
{
     looks through KList for Key; if found, returns in Rec.
     It and the routines that follow assume the procedure Seek
     for random access of the file of records.
}
var
  Item                : Integer;
begin
  Error := NoError;
  Item := FindKey(Key);
  if Item > 0
    then FRead(KList[Item].Num,Rec,Error)
    else Error := RecordNotFound
end; { of proc GetRecord }

procedure PutRecord(Rec : DataRec; var Error : Integer);
{
     writes Rec out to the file.  If a record with that
     key already exists, then overwrites that record;
     otherwise, adds the record to the end of the file.
     If there's no more room for records, exits with an
     error code
}
var
  Item         : Integer;
begin
  Error := NoError;
  Item := FindKey(Rec.Key);
  if Item >= 0
    then FWrite(KList[Item].Num,Rec,Error)
  else if MaxRec < IndexMax then begin
    MaxRec := MaxRec + 1;
    FWrite(MaxRec,Rec,Error);
    KList[MaxRec].Key := Rec.Key;
    KList[MaxRec].Num := MaxRec;
    SortIndexList
  end
  else Error := NoMoreRoom
end; { of proc PutRecord }

LISTING 4.  Basic record access routines.
----------


procedure AddRecord(Rec : DataRec; var Error : Integer);
{
     adds a record to the file.  If a record with the same
     key already exists, then exits with an error code
}
var
  Item         : Integer;
begin
  Error := NoError;
  Item := FindKey(Rec.Key);
  if Item > 0
    then Error := AlreadyExists
    else PutRecord(Rec,Error)
end; { of proc AddRecord }

procedure DeleteRecord(Key : Keytype; var Error : Integer);
{
     deletes the record with 'Key' by copying the last record
     in the file to that slot, then modifies KList by shuffling
     all the key entries up
}
var
  Item,Last,Max,MVal     : Integer;
  TRec                   : DataRec;
begin
  Error := NoError;
  Item := FindKey(Key);
  if Item = -1
    then Error := RecordNotFound
  else begin
    Max := 1; MVal := KList[Max].Num;
    for Last := 2 to MaxRec do
      if KList[Last].Num > MVal then begin
        Max := Last; MVal := KList[Last].Num
      end;
    if Max <> Item then begin
      FRead(MVal,TRec,Error);             { get last record in file }
      FWrite(KList[Item].Num,TRec,Error); { write over it }
      KList[Max].Num := KList[Item].Num
    end;
    for Last := Item to MaxRec-1 do     { delete KList[Item] }
      KList[Last] := KList[Last+1];
    MaxRec := MaxRec - 1                { adjust # of records }
  end
end; { of proc DeleteRecord }

LISTING 5.  Higher-level record access routines.
----------